;basic types
; int8, int16, int32, int64
; double, objectRef, bytestring

(defpackage "ian" 
  (:use :common-lisp))

(in-package "ian")


(defparameter *header* "/*******************************************************
* This file is generated automatically by gentypes.lisp.
* DO NOT MAKE CHANGES TO THIS FILE DIRECTLY.
********************************************************/

#ifndef __YJKTYPES_H
#define __YJKTYPES_H

#include <stdint.h>

// These are basic types that can exist in arrays.
#define YJK_BASETYPE_OBJECT 1
#define YJK_BASETYPE_INT8   2
#define YJK_BASETYPE_CHAR   3
#define YJK_BASETYPE_INT16  4
#define YJK_BASETYPE_INT32  5
#define YJK_BASETYPE_INT64  6
#define YJK_BASETYPE_FLOAT  7

#define YJK_BASETYPE_LIMIT  7
#define YJK_IS_BASETYPE(x) (x <= YJK_BASETYPE_LIMIT)


//Represents object type.
//Defined near end of file.
typedef uint8_t yjk_type_t;

typedef struct
{
  uint8_t    flags;
  yjk_type_t type;
  uint32_t   size;
} YJK_OBJECT_HEADER;


#ifndef __64BIT__
typedef struct 
{
  unsigned int tag : 2;
  int value : 30;
} YJK_MASK;
typedef int32_t YJK_FIXNUM;
#else
typedef struct
{
  unsigned int tag : 2;
  int value : 62;
} YJK_MASK;
typedef int64_t YJK_FIXNUM;
#endif

typedef void *YJK_FUNCTION;

")

;;; Often we need to create unique names.
;;; Gensym would work, but the results should
;;; be repeatable for generated code.
(let ((x 100))
  (defun unique-reset ()
    (setf x 100))
  (defun unique-name ()
    (format nil "~a" (setf x (1+ x)))))


(defun cserial (type name &optional elementtype arrayindex)
  (cond ((eq type 'int8)
	 (concatenate 'string "~%~2tyjk_serial_write(&obj->" name ", 1, output);~%"))
	((eq type 'char)
	 (concatenate 'string "~%~2tyjk_serial_write(&obj->" name ", 1, output);~%"))
	((eq type 'int16)
	 (concatenate 'string 
		      "~%~2tint16_t temp_" name " = htons(obj->" name arrayindex ");~%"
		      "~2tyjk_serial_write(&temp_" name ", 2, output);~%"))
	((eq type 'int32)
	 (concatenate 'string 
		      "~%~2tint32_t temp_" name " = htonl(obj->" name arrayindex ");~%"
		      "~2tyjk_serial_write(&temp_" name ", 4, output);~%"))
	((eq type 'int64)
	 (concatenate 'string 
		      "~%~2tint64_t temp_" name " = htonll(obj->" name arrayindex ");~%"
		      "~2tyjk_serial_write(&temp_" name "), 8, output);~%"))
	((eq type 'floatp)
	 (concatenate 'string 
		      "~%~2tchar temp_" name "[64];~%"
		      "~2tsnprintf(temp_" name ", 64, \"%le\", obj->" name arrayindex ");~%"
		      "~2tyjk_serial_write(temp_" name ", strlen(temp_" name ") + 1, output);~%"))
	((eq type 'objRef)
	 (let ((uid (unique-name)))
	   (concatenate 'string
			"~%~2tint object_id_" uid " = htonl(yjk_serial_lookup(obj->" name arrayindex "));~%"
			"~2tyjk_serial_write(&object_id_" uid ", 4, output);~%")))
	((eq type 'funcRef)
	 "")
	((eq type 'array)
	 (concatenate 'string
		      (cserial 'int32 (concatenate 'string name "_size"))
		      "~2tfor (int i = 0; i < obj->" name "_size; i++)~%"
		      "~2t{"
		      (cserial elementtype name nil "[i]")
		      "~2t}~%"
	 ))
	)) 
	
(if (fboundp 'make-all)
    (make-all))

(let ((ctypes '((int8 "int8_t")
		(int16 "int16_t")
		(int32 "int32_t")
		(int64 "int64_t")
		(floatp "double")
		(char  "unsigned char")
		(objRef "YJK_OBJECT")
		(funcRef "YJK_FUNCTION *"))))
  (defun ctype (type)
    (cadr
     (assoc type ctypes))))  


(defun cstruct (type name &optional elementtype) 
  (cond ((eq type 'flexarray)
	 (concatenate 'string 
		      "struct {~%~4tint32_t element_type; ~%~4tint32_t size; ~%~4tYJK_OBJECT data[]; ~%~2t} " name))
	((eq type 'array)
	 (concatenate 'string 
		      "int32_t " name "_size;~%~2t"
		      (ctype elementtype) " " name "[]"))
	(t
	 (concatenate 'string (ctype type) " " name))))


(defun make-cstruct (def)
  "Given a name and definition of a basic type, return a C structure definition"
  (destructuring-bind (name . definition) def
    (format nil 
	    (concatenate 
	     'string
	     "struct yjk_" name " {~%~2tYJK_OBJECT_HEADER head;~%"
	     (reduce 
	      (lambda (x y)
		(concatenate 'string x y))
	      (map 'list (lambda (x) 
			   (concatenate 
			    'string "~2t"
			    (cstruct (car x) (cadr x) (caddr x)) ";~%"))
		   definition))
	     "};~%typedef struct yjk_" (car def) " YJK_"  
	     (string-upcase (car def)) ";~%~%"))))
  

(defun make-cserial (def)
  (format nil 
	  (concatenate 
	   'string
	   "int~%" (car def) "_serialize(YJK_" 
	   (string-upcase (car def)) " *obj, YJK_SERIAL_OUT output)~%{~%"
	   "~2tuint8_t _OBJ_TYPE = YJK_" (string-upcase (car def)) "_T;~%"
	   "~2tyjk_serial_write(&_OBJ_TYPE, 1, output);~%"
	   (reduce 
	    (lambda (x y)
	      (concatenate 'string x y))
	    (map 'list (lambda (x) 
			 (concatenate 
			  'string 
			  (cserial (car x) (cadr x) (caddr x))))
		 (cdr def)))
	   "~%~2treturn 0;~%}~%~%"))) 



(defun make-c-header-file (typelist)
  (let ((typenum 10))
    (with-open-file (outfile "yjktypes.h" 
			     :direction :output 
			     :if-exists :supersede 
			     :if-does-not-exist :create)
      (format outfile *header*)

      ;;Forward declaration of structs
      (mapcar 
       #'(lambda (v)
	   (format outfile
		   (concatenate 'string
				"struct yjk_" (car v) ";~%")))
       typelist)

      ;;Define YJK_OBJECT
      (format outfile "typedef union 
{
  YJK_MASK   mask;
  YJK_FIXNUM fixnum;
  YJK_OBJECT_HEADER *head;
")
      (mapcar
       #'(lambda (v)
	   (format outfile
		   (concatenate 'string
				"  struct yjk_" (car v) " *" (car v) ";~%")))
       typelist)
      (format outfile "} YJK_OBJECT;~%~%")
      
      (mapcar 
       #'(lambda (v)
	   (format outfile 
		   (make-cstruct v)))
       typelist)
      (format outfile "#define YJK_FIXNUM_T ~28t~a~%" (incf typenum))
      (mapcar
       #'(lambda (v)
	   (format outfile "#define YJK_~a_T ~28t~a~%" (string-upcase (car v)) (incf typenum)))
       typelist)
      (format outfile "~%~%yjk_type_t yjk_get_type(YJK_OBJECT);~%~%#endif //__YJKTYPES_H~%"))))
    

(defun make-c-serial-file (typelist)
  (with-open-file (outfile "yjktypes.c"
			   :direction :output
			   :if-exists :supersede
			   :if-does-not-exist :create)
    (format outfile "/******************************************
* Automatically generated by gentypes.lisp.
* DO NOT EDIT THIS FILE DIRECTLY.
*******************************************/

#include <string.h>
#include <stdio.h>

//needed for htonl
#ifndef __WIN32__
#include <netinet/in.h>
#endif

#include \"yjktypes.h\"
#include \"serialize.h\"

yjk_type_t
yjk_get_type(YJK_OBJECT obj)
{
  printf(\"TAG: %d\n\", obj.mask.tag);
  if (obj.mask.tag & 0x1)
    {
      yjk_type_t t;
      obj.mask.tag = 0;
      t = obj.head->type;
      obj.mask.tag = 1;
      return t;
    }
  return YJK_FIXNUM_T;
}

~%~%")
    (mapcar 
     #'(lambda (v)
	 (format outfile 
		 (make-cserial v)))
     typelist)
    (format outfile 
	      "int
yjk_serialize(YJK_OBJECT obj, YJK_SERIAL_OUT output)
{
  switch(yjk_get_type(obj))
  {
")
    (mapcar
     #'(lambda (v)
	 (format outfile
		 (concatenate 
		  'string 
		  "~4tcase YJK_" (string-upcase (car v)) "_T:~%"
		  "~6treturn " (car v) "_serialize(obj." (car v) ", output);~%~6tbreak;~%")))
     typelist)
    (format outfile "~4tdefault: ~%~6tbreak; ~%~2t}~%  return 0;~%}~%~%")))


(defun make-all ()
  (let ((typelist 
	 '(
	   ("floatp" 
	    (floatp "value"))
	  
	   ("ratio" 
	    (objRef "numerator")
	    (objRef "denominator"))

	   ("complex"
	    (objRef "rpart")
	    (objRef "ipart"))
    
	   ("array" 
	    (flexarray "flex"))
    
	   ("hash" 
	    (int32 "num_elements")
	    (funcRef "hash_function")
	    (flexarray "buckets"))

	   ("bignum"
	    (array "data" int32))

	   ("utf8_string" 
	    (array "data" char))
	   ))) 
    (make-c-header-file typelist)
    (make-c-serial-file typelist)
    t))

(make-all)

